perm filename TRONLY.F4[PAG,LCS]6 blob
sn#575391 filedate 1981-03-26 generic text, type T, neo UTF8
C******** TRONLY, ZSIG, AVERG *********************************
SUBROUTINE TRONLY
COMMON /MIN/J,R,RT,XRT,RX
COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1) /PTR/JST(1)
1 /RCLF/KK,CLEF,KW,KTEM,RSTAFF,SN,YN,RNAM,IRV,ITR
1 /IPG/IPG,JPG,XCLEF,RSTNUM(8),RPSZ(8),RHGT(8),RRCLEF(8)
1 /ITX/ITX(18)
1 /TRAN/RTR(17),KTR(17)
EQUIVALENCE (ITEM,JST(18)),(ITOT,JST(19))
1000 FORMAT(' TYPE INPUT NAME.EXT ',$)
2200 FORMAT(A5,A1,A3)
2201 FORMAT(1XA5,'.',A3)
400 FORMAT(' OUTPUT NAME.EXT ',$)
6 FORMAT(' WRITE OVER ',A5,'.',A3,'? ',$)
8 FORMAT(A1)
304 FORMAT(' TRANSP.= '$)
306 FORMAT(I)
IDONE=0
SIG=-99
XSIG=0
300 TYPE 1000
ACCEPT 2200,NM,XIN,XIN
IF(XIN.EQ.' ')XIN='MS'
NX=NM+256
2001 TYPE 304
ACCEPT 2101,ITR
IF(ITR.GT.-20)GO TO 1101
2101 FORMAT(A3)
C NEXT FOR LETTER NAMES
DO 3101 K=1,18
3101 IF(ITR.EQ.ITX(K))GO TO 4101
5101 TYPE 240
GO TO 2001
240 FORMAT(' THIS TRANSP NOT OFFERED')
1101 REREAD 306,ITR
IF(ITR.EQ.0)GO TO 300
ITR=10-ITR
IF(ITR.EQ.22)ITR=17
C FOR DOWN OCT.
IF(ITR.GT.0)GO TO 700
IF(ITR.EQ.-2)ITR=18
C -2 NOW = UP OCT.
GO TO 700
4101 ITR=K
700 TYPE 400
ACCEPT 2200,NOUT,K,XOUT
IF(NOUT.NE.' ')GO TO 5
NOUT='AAAAA'
XOUT='TST'
C DEFAULT NAMES
5 IF(XOUT.EQ.' ')XOUT='TST'
IF(LOOKX(NOUT,XOUT).GE.0)GO TO 11
TYPE 6,NOUT,XOUT
ACCEPT 8,K
IF(K.EQ.'N')GO TO 700
11 JOUT=NOUT+256
10 IF(LOOKX(NM,XIN).LT.0)GO TO 9
NM=NX
NX=NX+256
C WILL READ UP TO 52 FILES.
NOUT=JOUT
JOUT=JOUT+256
IF(LOOKX(NM,XIN).LT.0)GO TO 9
IF(IDONE.EQ.0)TYPE 290
CALL EXIT
290 FORMAT(
1' **** FILE NOT FOUND. NAMES MUST HAVE 5 LETTERS.****')
9 IDONE=-1
CALL INMUS(NM,XIN,Q,KPN,JST)
TYPE 2201,NM,XIN
ITEM=ITEM-2
C NEXT SORTS INTO LEFT-TO-RIGHT
KL=1
JPG=ITEM-1
333 DO 33 K=KL,JPG
IF(CODEN(KPN,K,Q,J).GT.6)GO TO 33
A=Q(J+3)
DO 3333 J=K+1,JPG
IF(CODEN(KPN,J,Q,L).GT.6)GO TO 3333
IF(A.LE.Q(L+3))GO TO 3333
CALL EXCH(KPN(J),KPN(K))
GO TO 333
3333 CONTINUE
KL=K+1
33 CONTINUE
C NEXT FIND HOW MANY STAVES. KSIG?
RS=0
DO 32 K=1,ITEM
R=CODEN(KPN,K,Q,J)
IF(R.GT.2)GO TO 32
IF(Q(J+2).GT.RS)RS=Q(J+2)
32 IF(R.EQ.17)SIG=0
JPG=RS+1
JITEM=ITEM
IOCT=0
KW=0
IF(ITR.LE.17)GO TO 1002
RT=7
C OCTAVE ↑ = 19, - = 18
IF(ITR.EQ.18)RT=-RT
IOCT=-1
GO TO 199
C FOUND KSIG, SO DON'T DO THE REST
1002 IF(XSIG.NE.0)GO TO 199
RT=0
IF(ITR.EQ.0)RETURN
RT=RTR(ITR)
C EEb,EE,F-,F#-,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F,G↑ BBb, 8-, 8↑
41 NSIG=-1
IF(SIG.EQ.0)GO TO 699
C ASSUMES KSIG DESIRED IF ONE THERE ALREADY.
RSIG=-1
IF(ZSIG(XSIG).NE.'Y')GO TO 199
C FUNCTION ZSIG ASKS 'ADD KEY SIG?'
699 NSIG=0
RSIG=0
XSIG=99
C ***** NEXT FOR KEY SIG. ********
IADD=KTR(ITR)
C ADD= ADD OR SUBTR. # OR b FROM KSIG.
C EEb,EE,F-,F#-,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F,G BBb, 8-, 8↑
199 K=1
XCLEF=0
CLEF=-1
SLUR=0
PRX=99
MS=1
SN=KW
599 X=CODEN(KPN,K,Q,J)
IF(X.NE.4)GO TO 2
BAR=-1
MS=1
GO TO 100
2 IF(Q(J+2).NE.SN)GO TO 100
CHECK FOR STAFF NUM.
IF(X.EQ.1)GO TO 1
20 IF(X.NE.17)GO TO 12
RSIG=-1
R=Q(J+5)
C KSIG NUM.
A=R+IADD
CHANGED TO A
IF(ABS(A).LT.8)GO TO 123
C AVOIDS IMPOSSIBLE KSIG, DOES ENHARMONIC CHANGE.
IF(A.LT.0)GO TO 223
ITR=9
A=A-12
RT=RT+1
GO TO 123
223 A=A+12
ITR=11
RT=RT-1
123 IF(A.NE.0)GO TO 23
M=Q(J)+3
C THIS WILL DELETE KSIG
ITOT=ITOT-M
KL=ITOT-J
CALL RLOOP(Q(J),Q(J+M),KL)
DO 334 J=K,JITEM
334 KPN(J)=KPN(J+1)-M
JITEM=JITEM-1
K=K-1
GO TO 100
23 Q(J+5)=A
NSIG=0
12 IF(X.EQ.5)GO TO 120
IF(X.NE.3)GO TO 26
IF(Q(J+5).GT.3)GO TO 100
C SKIP NON-CLEFS
IF(CLEF.GE.0)GO TO 100
C FINDS ONLY 1 CLEF PER STAFF
XCLEF=Q(J+5)
IF(Q(J).LT.3)XCLEF=0
CLEF=0
GO TO 100
26 IF(X.NE.6)GO TO 100
120 IF(RT.NE.8)GO TO 121
IF(XCLEF.EQ.1)RT=-4
C WHAT ABOUT C CLEFS??
121 Q(J+4)=Q(J+4)+RT
Q(J+5)=Q(J+5)+RT
IF(X.EQ.5)SLUR=Q(J+6)
C SAVES RIGHT POS. OF SLUR
GO TO 100
C FOR BEAMS AND SLURS
1 CALL MINCVT
C3/81 1 R=Q(J+4)
C3/81 IF(R.LT.80.)GO TO 110
C3/81 IF(R.GE.100.)GO TO 110
C3/81 C NOW WE MUST CONVERT THE CODE FOR A MINI-NOTE
C3/81 R=R-200.
C3/81 C e.g. 97 IS CHANGED TO -103, A MINI AT LEVEL -3.
C3/81 C (BUT WHAT ABOUT -97?)
C3/81 Q(J+4)=R
C3/81 110 XRT=RT
C3/81 IF(Q(J).LT.6)GO TO 111
C3/81 C SKIP IF NO STEM INFO
C3/81 RX=Q(J+8)
C3/81 IF(RX.GT.999.0)GO TO 111
C3/81 IF(RX.EQ.999.0)RX=0
C3/81 RX=RX+RT
C3/81 IF(RX.LT.0)RX=0
C3/81 C RESET STEM LENGTH. NEVER SHORTER THAN 0 (NORMAL).
C3/81 Q(J+8)=RX
111 IF(IOCT.LT.0)GO TO 4
C IOCT=-1 FOR OCT+ OR OCT-
RX=AMOD(R,100.0)
RZ=AMOD(RX,7.0)
C THE NOTE NUM
IF(RZ.LT.0)RZ=RZ+7
C PUTS IT IN 0-6 RANGE FOR ACCI CHANGE SECTION.
R5=Q(J+5)
A=AMOD(R5,10.0)
C THE ACCI
RN(MS)=A
RN(MS+1)=RX
C SAVE FOR REPEATS
MS=MS+2
CHNAT=3
IF(MS.LT.4)GO TO 205
N=MS-3
200 IF(RX.NE.RN(N))GO TO 201
IF(A.EQ.0)GO TO 4
C NOW WE'VE FOUND THE SAME NOTE WITH NO ACCI IN SAME MEAS.
GO TO 203
201 N=N-2
IF(N.GE.1)GO TO 200
205 IF(NSIG.LT.0)CHNAT=0
203 ADD=A
C THE CHANGE IN ACCI
IF(PRX.NE.RX)GO TO 44
C IF PREV ACCI AND NT ARE SAME, SKIP OVER.
IF(A.NE.0)GO TO 44
C NOW SAME NOTE, NO ACCI
IF(ABS(SLUR-Q(J+3)).GT.3)GO TO 44
C FOUND CONNECTING TIE
C OR SET MS BACK TO 200 WHEN TIE IS PRESENT. THIS WILL
CAUSE LATER SAME NOTE TO HAVE ACCI (I HOPE.)
IF(BAR.LT.0)MS=1
IF(A.NE.0)GO TO 203
GO TO 4
44 IF(NSIG.LT.0)GO TO 440
CCC IF(ITR.GE.17)GO TO 69
IF(A.EQ.0)GO TO 4
C ONLY CHECKS ON NOTES WITH NO ACCI
IF(ITR.GE.18)GO TO 4
440 IF(XCLEF.NE.1)GO TO 69
RZ=RZ-5
IF(RZ.LT.0)RZ=RZ+7
69 N=A+1
GO TO (63,52,53,54,55, 56,57,58,59,440, 61,62,63,52,53,55
1 ,64),ITR
C EEb,EE,F-,F#-,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F BBb
54 IF(RZ.EQ.3)GO TO 101
59 IF(RZ.EQ.6)GO TO 101
52 IF(RZ.EQ.2)GO TO 101
57 IF(RZ.EQ.5)GO TO 101
C FOR "A". FINDS C,F AND G.
62 IF(RZ.EQ.1)GO TO 101
55 IF(RZ.EQ.4)GO TO 101
C "G" F→Bb, F#→B NAT.
GO TO 4
61 IF(RZ.EQ.5)GO TO 7
56 IF(RZ.EQ.2)GO TO 7
63 IF(RZ.EQ.6)GO TO 7
58 IF(RZ.EQ.3)GO TO 7
53 IF(RZ.NE.0)GO TO 4
7 GO TO(402,30,405,402,401)N
30 ADD=CHNAT
C MAKE IT NAT. IF NEEDED
3 Q(J+5)=R5-A+ADD
4 PRX=RX
C REAL NOTE LEVEL
Q(J+4)=R+XRT
BAR=0
100 IF(K.GE.JITEM)GO TO 499
K=K+1
GO TO 599
C NEXT FOR BSCLAR.---ADD OTHERS HERE!!!
64 IF(XCLEF.EQ.1)XRT=XRT-12
GO TO 58
101 GO TO(401,404,30,401,404,402)N
C WON'T HANDLE Gbb→Ab
404 ADD=4
GO TO 3
401 ADD=1
GO TO 3
402 ADD=2
GO TO 3
405 ADD=5
GO TO 3
499 KW=KW+1
IF(RSIG.LT.0)GO TO 498
IF(IADD.EQ.0)GO TO 498
M=ITOT
C INSERT NEW KSIG
Q(M)=4
Q(M+1)=17
Q(M+2)=SN
Q(M+3)=9
Q(M+4)=0
Q(M+5)=IADD
Q(M+6)=XCLEF
ITOT=ITOT+7
JITEM=JITEM+1
KPN(JITEM+1)=ITOT
498 IF(KW.LT.JPG)GO TO 199
CALL RVRS(JITEM)
C TO REVERSE STEMS, BEAMS AND SLURS
497 DO 496 K=1,ITEM-1
C THIS REORDERS PTR ARRAY
IF(KPN(K).LT.KPN(K+1))GO TO 496
CALL EXCH(KPN(K),KPN(K+1))
GO TO 497
496 CONTINUE
CALL PUTEXT(NOUT,XOUT)
ITEM=JITEM+2
CALL EXTOUT(JST,128)
C*** CALL EXTOUT(KPN,ITEM)
C ABOVE NOT NEEDED WITH NEW SAVE FORMAT.
CALL EXTOUT(Q,ITOT)
CALL FINEXT
TYPE 2201,NOUT,XOUT
NOUT=NOUT+2
NM=NM+2
GO TO 10
END
FUNCTION ZSIG(XSIG)
TYPE 42
42 FORMAT(' ADD KEY SIG? -- ',$)
43 FORMAT(A1)
ACCEPT 43,XSIG
ZSIG=XSIG
END
FUNCTION AVERG(J,JJ,LEND)
COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
1 /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,IRV,ITR
1 /IPG/IPG,JPG,BRA(8),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(8)
C FIRST GET RIGHT END POSITION OF BEAM
END=Q(JJ+6)+.2
LL=Q(JJ+7)/10.
C STEM DIRECTION OF BEAM
BOT=999.
TOP=-BOT
AVERG=0
K=J
1 R=CODEN(KPN,K,Q,KK)
C FIND CODE NUM.
IF(Q(KK+3).GT.END)GO TO 3
C JUMP OUT IF PAST RIGHT SIDE OF BEAM
IF(R.NE.1)GO TO 2
C JUMP IF NOT A NOTE
IF(Q(KK+2).NE.SN)GO TO 2
C JUMP IF NOT ON RIGHT STAFF
L=Q(KK+5)/10.
IF(L.NE.LL)GO TO 4
C JUMP OUT IF ANY NOTE HAS WRONG STEM DIRECTION.
A=AMOD(Q(KK+4),100.0)
C GET HEIGHT OF NOTE
IF(A.LT.BOT)BOT=A
IF(A.GT.TOP)TOP=A
2 K=K+1
IF(K.GT.LEND)GO TO 4
C IF AT END OF DATA, JUMP OUT (SHOULD NOT GET HERE!)
GO TO 1
3 A=(TOP+BOT)/2.
C AVERG=0=STEMS SHOULD GO UP, 1=DOWN
IF(A.GE.7)AVERG=1.
RETURN
4 IF(LL.EQ.2)AVERG=1.
C USE STEM DIR. OF BEAM IF NOTES HAVE VARYING STEMS.
END
SUBROUTINE MINCVT
COMMON /MIN/J,R,RT,XRT,RX /Q/Q(1)
R=Q(J+4)
IF(R.LT.80.)GO TO 110
IF(R.GE.100.)GO TO 110
C NOW WE MUST CONVERT THE CODE FOR A MINI-NOTE
R=R-200.
C e.g. 97 IS CHANGED TO -103, A MINI AT LEVEL -3.
C (BUT WHAT ABOUT -97?)
Q(J+4)=R
110 XRT=RT
IF(Q(J).LT.6)RETURN
C SKIP IF NO STEM INFO
RX=Q(J+8)
IF(RX.GT.999.0)RETURN
IF(RX.EQ.999.0)RX=0
RX=RX+RT
IF(RX.LT.0)RX=0
C RESET STEM LENGTH. NEVER SHORTER THAN 0 (NORMAL).
Q(J+8)=RX
END